home *** CD-ROM | disk | FTP | other *** search
Text File | 1990-08-20 | 36.8 KB | 333 lines | [ TEXT/CCL ]
(export (quote (peval papply pcall parse parsefile parsestring parselist parsestream reparse defpfun addrules removerules getrules sourcelanguage targetlanguage identifier adelimiter anumber astring atype reservedword nonreservedword eof isnot flush pvariable lhs rhs phs onleft onright pwarning perror checkfunction empty? peek next nextis? nextare? failure failed? failurevalue? plispfunction? leftside? rightside? cat neql nequal nequalp plist pname printc str ptrace pfulltrace ptrap puntrace punfulltrace puntrap literal variable call repeat alternatives beginlist endlist lisp literals branches rewritesto)) :glisp) (export (quote (*lisp-readtable* *glisp-readtable* *glisp-sexp-readtable* *pstandard-output* *perror-output* *ptrace-output*)) :glisp) (export (quote (! @ \# $ % ^ & * \( \) _ + - = { } [ ] \: \" \; \' < > ? \, \. / ~ \` \| \\ \:= <= >= /= \¡ \™ \£ \¢ \∞ \§ \¶ \• \ª \º \– \≠ \∑ \´ \® \† \¥ \¨ ^ \π \“ \‘ \∂ \ƒ \© \Δ \¬ \… \Ω \≈ \√ \∫ \µ \≤ \≥ \÷ \« \° \— \± \∏ \” \’ \ \◊ \¿ \» \œ \ø \å \æ \ç \ß \Œ \Ø \Å \Æ \Ç all done)) :glisp) (defvar !reservedwords nil "(list) identifiers unquoted on left sides of rules") (defvar !nredefined 0 "(integer) number of functions that were redefined") (defvar !source nil "(headed list) the current input stream") (defvar !savedsources nil "(stack) for backtracking; a stack because of flush") (defvar !sourcestream nil "(stream/list) not-yet-scanned tail of input stream") (defvar !sourcestack nil "(stack) for managing nested input") (defvar !deststack nil "(stack) for managing nested output") (defvar !sidestack nil "(stack) booleans saying which side of a rule we're on") (defvar !sourcelanguage nil "(symbol) the language in which the input is written") (defvar !targetlanguage nil "(symbol) the language defined by the input, if any") (defvar !farthestindex 0 "(integer) index of farthest point reached in input") (defvar !farthesttail nil "(list) remaining input at last advance of list input") (defvar !farthestfailure nil "(string) failure message at farthest point in input") (defvar !farthestfunction nil "(symbol) name of function containing !farthestFailure") (defvar !varnames nil "(association list) for translating :variable names") (defvar !pindent 0 "(integer) indentation level for trace output") (defvar !currentplispfunction nil "(symbol) name of current Plisp function--for tracing") (proclaim (quote (special *readtable*))) (defvar !dest nil "(headed list) current output stream") (defvar !variables nil "(association list) the current :variable bindings") (defvar !inrepeat nil "(t, nil) are we inside a repeat [ ]* ?") (defvar !repeatcount 0 "(integer) number of times through the current repeat") (defvar !ptrace nil "(t, nil) are Plisp functions being traced?") (defvar *lisp-readtable* nil "(readtable) standard Common Lisp definition") (defvar *glisp-readtable* nil "(readtable) Glisp definition") (defvar *glisp-sexp-readtable* nil "(readtable) Glisp definition in s-expressions") (defvar *pstandard-output* nil "(stream) the standard Glisp output stream") (defvar *ptrace-output* nil "(stream) Glisp stream for tracing") (defvar *perror-output* nil "(stream) Glisp stream for errors") (proclaim (quote (special *trace-print-length*))) (setq *trace-print-length* 10) (proclaim (quote (special *trace-print-level*))) (setq *trace-print-level* 5) (proclaim (quote (special *print-abbreviate-quote*))) (proclaim (quote (object-variable ccl::index ccl::end))) (defmacro failed? (ex) (cons (quote catch) (cons (quote !failure) (cons ex (quote (nil)))))) (defsetf veval vset) (defun slvariable (var) (cond ((vbound? var) (prog ((value (veval var (not !inrepeat)))) (cond ((and !inrepeat (listp value)) (cond ((> !repeatcount (length value)) (vset var (addvalue value !repeatcount (next)))) (t (or (nextis? (nth (- !repeatcount 1) value)) (failure (cat ":" var)))))) (t (or (nextis? value) (failure (cat ":" var))))))) (!inrepeat (cond ((empty?) (failure (cat ":" var))) (t (vset var (list (next)))))) ((empty?) (failure (cat ":" var))) (t (vset var (next))))) (defun srvariable (var) (prog ((value (cond ((vbound? var) (veval var nil)) (t (vset var nil))))) (cond ((and !inrepeat (listp value)) (cond ((> !repeatcount (length value)) (failure (cat ":" var))) (t (setf !dest (xcons !dest (nth (- !repeatcount 1) value)))))) (t (setf !dest (xcons !dest value)))))) (defun mlvariable (var takeallinput firsttime) (cond ((vbound? var) (prog ((value (veval var (and firsttime (not !inrepeat))))) (cond ((not (listp value)) (perror "the value of ::" var " is not a list: " value)) (!inrepeat (cond ((> !repeatcount (length value)) (vset var (addvalue value !repeatcount (nconc (nth (- !repeatcount 1) value) (list (next)))))) (t (or (nextare? (nth (- !repeatcount 1) value)) (failure (cat "::" var)))))) (firsttime (or (nextare? value) (failure (cat "::" var)))) (t (vset var (nconc value (list (next)))))))) (!inrepeat (cond ((empty?) (failure (cat "::" var))) (t (vset var (list (next)))))) (takeallinput (cond ((null !sourcestream) (vset var (cdr !source)) (setf !source (xnew))) (t (perror "shouldn't happen")))) (t (vset var (list (next)))))) (defun mrvariable (var) (prog ((value (cond ((vbound? var) (veval var nil)) (t (vset var nil))))) (cond ((not (listp value)) (perror "the value of ::" var " is not a list: " value)) (!inrepeat (cond ((> !repeatcount (length value)) (failure (cat "::" var))) (t (setf !dest (xappend !dest (nth (- !repeatcount 1) value)))))) (t (setf !dest (xappend !dest value)))))) (defun lcall (fn args many) (prog (value (!currentplispfunction fn)) (setf value (cond ((plispfunction? fn) (setf !source (xprepend args !source)) (apply fn nil)) (t (list (apply fn args))))) (cond ((or (null value) (eq (car value) !novalue)) nil) (many (do (v (&v& (reverse value) (cdr &v&)) glisp::&v) ((atom &v&) glisp::&v) (setq v (car &v&)) (setq glisp::&v (setf !source (xprepend v !source))))) (t (setf !source (xprepend value !source)))))) (defun rcall (fn args many) (prog (value (!currentplispfunction fn)) (cond ((plispfunction? fn) (setf !source (xprepend args !source)) (setf value (apply fn nil))) (t (setf value (list (apply fn args))))) (cond ((or (null value) (eq (car value) !novalue)) nil) (many (do (v (&v& value (cdr &v&)) glisp::&v) ((atom &v&) glisp::&v) (setq v (car &v&)) (setq glisp::&v (setf !dest (xappend !dest v))))) (t (setf !dest (xappend !dest value)))))) (defun repeatmax (var) (cond ((vbound? var) (veval var nil)) (t nil))) (defun repeatstop? (max) (prog nil (setf !repeatcount (+ !repeatcount 1)) (return (and max (> !repeatcount max))))) (defun repeatset (var min) (prog nil (setf !repeatcount (- !repeatcount 1)) (cond ((not (vbound? var)) (vset var !repeatcount))) (cond ((or (< !repeatcount min) (< !repeatcount (veval var nil))) (failure (cat (max min (veval var nil)) " iterations in a repeat [...]*")))))) (defun altcheck (var) (cond ((vbound? var) (veval var nil)) (t (perror "unmatched alternatives on the right side of a rule")))) (defun lbeginlist nil (cond ((listp (peek)) (pushsource (next))) ((nextis? !lparen) (pushsource (readsourcelist))) (t (failure "(")))) (defun rbeginlist nil (push !dest !deststack) (setf !dest (xnew))) (defun lendlist nil (cond ((and (empty?) !sourcestack) (popsource)) (t (failure ")")))) (defun rendlist nil (setf !dest (xcons (pop !deststack) (cdr !dest)))) (defun beginplispfunction (fn) (cond ((and !ptrace (or (get fn (quote ptrace)) (get fn (quote pfulltrace)))) (prog nil (setf !pindent (+ !pindent 1)) (indentedprintc "Calling <" fn ">") (cond ((get fn (quote pfulltrace)) (prog ((rules (getrules fn))) (indentedprintc "pattern: ") (cond ((null rules) (princ nil *ptrace-output*)) (t (uncompilepattern rules *trace-print-length*)))))) (indentedprintc "input: ") (princlist (rest !source) *ptrace-output*) (terpri *ptrace-output*) (cond ((get fn (quote ptrap)) (pbreak))))))) (defun endplispfunction (fn) (prog nil (cond ((and !ptrace (or (get fn (quote ptrace)) (get fn (quote pfulltrace)))) (prog nil (indentedprintc "<" fn "> -> ") (princlist (rest !dest) *ptrace-output*) (terpri *ptrace-output*) (cond ((get fn (quote ptrap)) (pbreak))) (setf !pindent (- !pindent 1))))) (return (cdr !dest)))) (defun setdecisionpoint nil (prog nil (push !pindent !savedsources) (push (cdr !source) !savedsources) (push !sourcestream !savedsources) (push !sourcestack !savedsources) (push (cdr !dest) !savedsources) (push !deststack !savedsources) (push !variables !savedsources))) (defun restoredecisionpoint nil (prog nil (setf !pindent (seventh !savedsources)) (setf !source (xhead (sixth !savedsources))) (setf !sourcestream (fifth !savedsources)) (setf !sourcestack (cadddr !savedsources)) (setf !dest (xhead (caddr !savedsources))) (setf !deststack (cadr !savedsources)) (setf !variables (car !savedsources)) (return t))) (defun deletedecisionpoint nil (prog nil (setf !savedsources (nthcdr 7 !savedsources)) (return t))) (defun pushsource (newsource) (prog nil (push (rest !source) !sourcestack) (push !sourcestream !sourcestack) (setf !source (xhead newsource)) (setf !sourcestream nil))) (defun popsource nil (setf !sourcestream (pop !sourcestack)) (setf !source (xhead (pop !sourcestack)))) (defun vbound? (var) (assoc var !variables)) (defun veval (var &optional (traceit t)) (prog (x) (cond ((null (setf x (assoc var !variables))) (setf x (cons var nil)))) (cond ((and !ptrace (get !currentplispfunction (quote pfulltrace)) traceit) (indentedprintc ":" var " = " (cdr x)) (terpri *ptrace-output*))) (return (cdr x)))) (defun vset (var val &optional (traceit t)) (prog nil (setf !variables (cons (cons var val) (remove (assoc var !variables) !variables))) (cond ((and !ptrace (get !currentplispfunction (quote pfulltrace)) traceit) (indentedprintc ":" var " := " val) (terpri *ptrace-output*))) (return val))) (defun addvalue (l i value) (cond ((= i 1) (cons value (cdr l))) (t (cons (car l) (addvalue (cdr l) (- i 1) value))))) (defun canonicalname (var onleft &aux x) (cond ((member var (quote (\. [ \|))) (cond (onleft (newname var)) ((setf x (assoc var !varnames)) (setf (car x) (gensym)) (cdr x)) ((eq var (quote \.)) (pwarning "too many ...'s on the right side of a rule") (newname (gensym))) (t (newname (gensym))))) ((setf x (assoc var !varnames)) (cdr x)) (onleft (newname var)) (t (pwarning "unbound variable on the right side of a rule: " var) (newname var)))) (defun newname (var) (cdar (setf !varnames (cons (cons var (+ (length !varnames) 1)) !varnames)))) (defun restorename (var val) (prog nil (do (pair (&pair& !varnames (cdr &pair&)) glisp::&v) ((atom &pair&) glisp::&v) (setq pair (car &pair&)) (if (cond ((= (cdr pair) val) (setf (car pair) var))) (return glisp::&v))) (return !novalue))) (defun recordmessage (message override) (cond ((and message (or (null !farthestfailure) override) (not (xnull? !source)) (or (null (cddr !source)) (eq !farthesttail (rest !source)))) (setf !farthestfailure message) (setf !farthestfunction !currentplispfunction)))) (defun princatom (name &optional (stream *pstandard-output*)) (princ name stream) (princ " " stream)) (defun princlist (l &optional (stream *ptrace-output*)) (do (x (&x& l (cdr &x&)) glisp::&v) ((atom &x&) glisp::&v) (setq x (car &x&)) (setq glisp::&v (princatom x stream)))) (defun readsourcelist nil (let ((*readtable* (cond ((eq *readtable* *glisp-readtable*) *glisp-sexp-readtable*) (t *readtable*)))) (cond ((or (empty?) (nextis? !rparen)) nil) (t (cons (next) (readsourcelist)))))) (defun readsexpression (stream) (let ((*readtable* (cond ((eq *readtable* *glisp-readtable*) *glisp-sexp-readtable*) (t *readtable*)))) (read-preserving-whitespace stream nil !eof nil))) (defun lispread (&optional stream eofp eofvalue recursivep) (let ((*readtable* *lisp-readtable*)) (cond ((consp stream) (xpop stream)) (t (read stream eofp eofvalue recursivep))))) (defmacro defpfun (name args body rules) (cons (quote &defpfun) (cons (cons (quote quote) (list name)) (cons (cons (quote quote) (list args)) (cons (cons (quote quote) (list body)) (list (cons (quote quote) (list rules)))))))) (defun &defpfun (name args body rules) (prog nil (setf (get name (quote prules)) rules) (setf (get name (quote pfunction)) t) (eval (list (quote defun) name args body)))) (defun addrules (name rules appearanceorder) (prog nil (eval (papply (quote expandrules) (list name (papply (quote mergerules) (list (reverse rules) (getrules name) appearanceorder))))) (return !novalue))) (defun removerules (name rules) (prog ((tree (getrules name))) (do (rule (&rule& rules (cdr &rule&)) glisp::&v) ((atom &rule&) glisp::&v) (setq rule (car &rule&)) (setq glisp::&v (setf tree (papply (quote removerule) (list (lhsonly rule) tree))))) (eval (papply (quote expandrules) (list name tree))) (return !novalue))) (defun getrules (name) (get name (quote prules))) (defun lhsonly (rule) (cond ((null rule) nil) ((equal (car rule) (quote (rewritesto))) (list (car rule))) (t (cons (car rule) (lhsonly (cdr rule)))))) (defun linearmatch (l1 l2) (equalp l1 (firstn (length l1) l2))) (defun firstn (n l) (cond ((or (< n 1) (null l)) nil) (t (cons (car l) (firstn (- n 1) (cdr l)))))) (defun makereservedword (word) (prog nil (cond ((and !targetlanguage (leftside?)) (setf !reservedwords (adjoin word !reservedwords)))) (return word))) (defun reservedwords nil (cond (!targetlanguage (list (quote declarereservedwords) (list (quote quote) !targetlanguage) (list (quote quote) (sort !reservedwords (function string-lessp))))) (t !novalue))) (defun declarereservedwords (language words) (prog nil (do (word (&word& words (cdr &word&)) glisp::&v) ((atom &word&) glisp::&v) (setq word (car &word&)) (setq glisp::&v (setf (get word language) t))) (setf (get language (quote reservedwords)) words) (export words) (export (list language)))) (defun addreservedwords (language words) (prog ((l (get language (quote reservedwords)))) (do (word (&word& words (cdr &word&)) glisp::&v) ((atom &word&) glisp::&v) (setq word (car &word&)) (setq glisp::&v (progn (setf (get word language) t) (setf l (adjoin word l))))) (setf (get language (quote reservedwords)) (sort l (function string-lessp))) (export words))) (defun sourcelanguage (language) (setf !sourcelanguage language) !novalue) (defun targetlanguage (language) (setf !targetlanguage language) !novalue) (defun xhead (l) (cond ((consp l) (cons (last l) l)) (t (let ((hl (cons l nil))) (setf (car hl) hl) hl)))) (defun xnew nil (let ((hl (cons nil nil))) (setf (car hl) hl) hl)) (defun xnull? (hl) (null (cdr hl))) (defun xcons (hl x) (setf (cdar hl) (cons x nil)) (setf (car hl) (cdar hl)) hl) (defun xappend (hl l) (cond ((null l) hl) (t (xappend (xcons hl (car l)) (cdr l))))) (defun xprepend (l hl) (cond ((null l) hl) (t (cond ((xnull? hl) (setf (car hl) (last l))) (t (setf (cdr (last l)) (cdr hl)))) (setf (cdr hl) l) hl))) (defun xpop (hl) (cond ((null (cddr hl)) (prog1 (cadr hl) (setf (cdr hl) (cddr hl)) (setf (car hl) hl))) (t (prog1 (cadr hl) (setf (cdr hl) (cddr hl)))))) (defmacro ptrace (&rest pfunctions) (cons (quote &ptrace) (list (cons (quote quote) (list pfunctions))))) (defmacro pfulltrace (&rest pfunctions) (cons (quote &pfulltrace) (list (cons (quote quote) (list pfunctions))))) (defmacro ptrap (&rest pfunctions) (cons (quote &ptrap) (list (cons (quote quote) (list pfunctions))))) (defmacro puntrace (&rest pfunctions) (cons (quote &puntrace) (list (cons (quote quote) (list pfunctions))))) (defmacro punfulltrace (&rest pfunctions) (cons (quote &puntrace) (list (cons (quote quote) (list pfunctions))))) (defmacro puntrap (&rest pfunctions) (cons (quote &puntrace) (list (cons (quote quote) (list pfunctions))))) (defun &ptrace (pfunctions) (cond ((null pfunctions) (setf !ptrace t) (get (quote all) (quote tracelist))) (t (&puntrace pfunctions) (setf !ptrace t) (do (pfn (&pfn& pfunctions (cdr &pfn&)) glisp::&v) ((atom &pfn&) glisp::&v) (setq pfn (car &pfn&)) (setq glisp::&v (nconc glisp::&v (list (cond ((plispfunction? pfn) (setf (get pfn (quote ptrace)) t) (setf (get (quote all) (quote tracelist)) (cons pfn (get (quote all) (quote tracelist)))) pfn) (t nil))))))))) (defun &pfulltrace (pfunctions) (cond ((null pfunctions) (setf !ptrace t) (get (quote all) (quote tracelist))) (t (&puntrace pfunctions) (setf !ptrace t) (do (pfn (&pfn& pfunctions (cdr &pfn&)) glisp::&v) ((atom &pfn&) glisp::&v) (setq pfn (car &pfn&)) (setq glisp::&v (nconc glisp::&v (list (cond ((plispfunction? pfn) (setf (get pfn (quote pfulltrace)) t) (setf (get (quote all) (quote tracelist)) (cons pfn (get (quote all) (quote tracelist)))) pfn) (t nil))))))))) (defun &ptrap (pfunctions) (cond ((null pfunctions) (setf !ptrace t) (get (quote all) (quote tracelist))) (t (&puntrace pfunctions) (setf !ptrace t) (do (pfn (&pfn& pfunctions (cdr &pfn&)) glisp::&v) ((atom &pfn&) glisp::&v) (setq pfn (car &pfn&)) (setq glisp::&v (nconc glisp::&v (list (cond ((plispfunction? pfn) (setf (get pfn (quote pfulltrace)) t) (setf (get pfn (quote ptrap)) t) (setf (get (quote all) (quote tracelist)) (cons pfn (get (quote all) (quote tracelist)))) pfn) (t nil))))))))) (defun &puntrace (pfunctions) (prog (value) (cond ((or (null pfunctions) (equal pfunctions (quote (all)))) (setf pfunctions (reverse (get (quote all) (quote tracelist)))))) (setf value (do (pfn (&pfn& pfunctions (cdr &pfn&)) glisp::&v) ((atom &pfn&) glisp::&v) (setq pfn (car &pfn&)) (setq glisp::&v (nconc glisp::&v (list (cond ((or (get pfn (quote ptrace)) (get pfn (quote pfulltrace)) (get pfn (quote ptrap))) (setf (get pfn (quote ptrace)) (setf (get pfn (quote pfulltrace)) (setf (get pfn (quote ptrap)) nil))) (setf (get (quote all) (quote tracelist)) (remove pfn (get (quote all) (quote tracelist)))) pfn) (t nil))))))) (cond ((null (get (quote all) (quote tracelist))) (setf !ptrace nil))) (return value))) (defun indentedprintc (&rest args) (prog ((*print-length* *trace-print-length*) (*print-level* *trace-print-level*)) (terpri *ptrace-output*) (do ((i 1 (+ i 1)) (&i& (- !pindent 1)) glisp::&v) ((> i &i&) glisp::&v) (setq glisp::&v (princ " " *ptrace-output*))) (princ "(" *ptrace-output*) (princ !pindent *ptrace-output*) (princ ") " *ptrace-output*) (do ((i 1 (+ i 1)) (&i& *print-length*) a (&a& args (cdr &a&)) glisp::&v) ((or (> i &i&) (atom &a&)) glisp::&v) (setq a (car &a&)) (setq glisp::&v (cond ((stringp a) (princ a *ptrace-output*)) (t (prin1 a *ptrace-output*))))))) (defun pbreak nil (prog ((*readtable* *lisp-readtable*)) (terpri *ptrace-output*) (break) (terpri *ptrace-output*))) (defun uncompilepattern (pattern n &optional (stream *ptrace-output*)) (cond ((null pattern) n) ((<= n 0) (princ "..." stream) 0) (t (uncompilepattern (rest pattern) (uncompileitem (first pattern) n stream) stream)))) (defun uncompileitem (item n &optional (stream *ptrace-output*)) (cond ((atom item) (princatom item stream) (- n 1)) (t (case (car item) (literal (princatom (cadr item) stream) (- n 1)) (variable (prog nil (princ (cond ((caddr item) "::") (t ":")) stream) (princatom (cadr item) stream) (return (cond ((cadddr item) (uncompilepattern (cadddr item) (- n 1) stream)) (t (- n 1)))))) (call (prog nil (princ (cond ((cadddr item) "<<") (t "<")) stream) (princ (cadr item) stream) (cond ((caddr item) (princ " " stream) (setf n (uncompilepattern (caddr item) (- n 1) stream)))) (princ (cond ((cadddr item) ">> ") (t "> ")) stream) (return n))) (alternatives (prog ((patterns (cddr item))) (princ "[ " stream) (setf n (uncompilepattern (first patterns) n stream)) (cond ((or (> (length patterns) 2) (second patterns)) (do (pattern (&pattern& (rest patterns) (cdr &pattern&)) glisp::&v) ((atom &pattern&) glisp::&v) (setq pattern (car &pattern&)) (setq glisp::&v (progn (princ "| " stream) (setf n (uncompilepattern pattern n stream))))))) (princ "] " stream) (return n))) (repeat (prog nil (princ "[ " stream) (setf n (uncompilepattern (cadddr item) n stream)) (cond ((fifth item) (princ "/ " stream) (setf n (uncompilepattern (fifth item) n stream)))) (princ (cond ((= (caddr item) 0) "]* ") (t "]+ ")) stream) (return n))) (beginlist (princ "( " stream) (- n 1)) (endlist (princ ") " stream) (- n 1)) (lisp (prog nil (princ (cond ((and (eq (cadr item) (quote value)) (cadddr item)) "{{") (t "{")) stream) (princatom (cadr item) stream) (prin1 (caddr item) stream) (princ (cond ((and (eq (cadr item) (quote value)) (cadddr item)) "}} ") (t "} ")) stream) (return (- n 2)))) ((literals branches) (prog nil (princ "{" stream) (princatom (car item) stream) (uncompilepattern (cadr item) 1 stream) (do (pattern (&pattern& (cddr item) (cdr &pattern&)) glisp::&v) ((atom &pattern&) glisp::&v) (setq pattern (car &pattern&)) (setq glisp::&v (progn (princ ", " stream) (uncompilepattern pattern 1 stream)))) (princ "} " stream) (return 0))) (rewritesto (princ "-> " stream) (- n 1)) (t (princatom item stream) (- n 1)))))) (defun humanize (item) (string-downcase (humanize1 item))) (defun humanize1 (item) (cond ((null item) "something") ((atom item) (str item)) (t (case (car item) (literal (cat "'" (cat (cadr item) "'"))) (variable (cat (cond ((caddr item) "::") (t ":")) (cadr item))) (call (cat "<" (cat (cadr item) ">"))) (alternatives (prog (s (patterns (cddr item))) (setf s (humanize1 (first (first patterns)))) (do (pattern (&pattern& (rest patterns) (cdr &pattern&)) glisp::&v) ((atom &pattern&) glisp::&v) (setq pattern (car &pattern&)) (setq glisp::&v (setf s (cat s (cat " or " (humanize1 (first pattern))))))) (return s))) (repeat "something") (beginlist "'('") (endlist "')'") (lisp (case (cadr item) (if (cat "'" (cat (caddr item) "' to be true"))) (do (cat "'" (cat (caddr item) "' to not fail"))) (value (cat "the value of '" (cat (caddr item) "'"))) (t (pwarning (cat "unknown item in a pattern: " item)) ""))) (literals (prog ((s (humanize1 (list (quote literal) (first (cadr item)))))) (do (pattern (&pattern& (cddr item) (cdr &pattern&)) glisp::&v) ((atom &pattern&) glisp::&v) (setq pattern (car &pattern&)) (setq glisp::&v (setf s (cat s (cat " or " (humanize1 (list (quote literal) (first pattern)))))))) (return s))) (branches (prog ((s (humanize1 (first (cadr item))))) (do (pattern (&pattern& (cddr item) (cdr &pattern&)) glisp::&v) ((atom &pattern&) glisp::&v) (setq pattern (car &pattern&)) (setq glisp::&v (setf s (cat s (cat " or " (humanize1 (first pattern))))))) (return s))) (rewritesto "nothing") (t (pwarning (cat "unknown item in a pattern: " item)) ""))))) (defun ruletostring (rule) (with-output-to-string (out) (patterntostring rule out))) (defun patterntostring (pattern out) (cond (pattern (itemtostring (first pattern) out) (do (item (&item& (rest pattern) (cdr &item&)) glisp::&v) ((atom &item&) glisp::&v) (setq item (car &item&)) (setq glisp::&v (progn (princ " " out) (itemtostring item out))))))) (defun itemtostring (item out) (cond ((null item) nil) ((atom item) (princ item out)) (t (case (car item) (literal (princ (cadr item) out)) (variable (prog nil (princ (cond ((caddr item) "::") (t ":")) out) (princ (cadr item) out) (cond ((cadddr item) (princ " " out) (patterntostring (cadddr item) out))))) (call (prog nil (princ (cond ((cadddr item) "<<") (t "<")) out) (princ (cadr item) out) (cond ((caddr item) (princ " " out) (patterntostring (caddr item) out))) (princ (cond ((cadddr item) ">>") (t ">")) out))) (alternatives (prog ((patterns (cddr item))) (princ "[" out) (cond ((null patterns) nil) ((and (= (length patterns) 2) (null (cadr patterns))) (patterntostring (first patterns) out)) (t (patterntostring (first patterns) out) (do (pattern (&pattern& (rest patterns) (cdr &pattern&)) glisp::&v) ((atom &pattern&) glisp::&v) (setq pattern (car &pattern&)) (setq glisp::&v (progn (princ " | " out) (patterntostring pattern out)))))) (princ "]" out))) (repeat (prog nil (princ "[" out) (patterntostring (cadddr item) out) (cond ((fifth item) (princ " / " out) (patterntostring (fifth item) out))) (princ (cond ((= (caddr item) 0) "]*") (t "]+")) out))) (beginlist (princ "(" out)) (endlist (princ ")" out)) (lisp (case (cadr item) (if (princ (cat "{if " (cat (caddr item) "}")) out)) (do (princ (cat "{do " (cat (caddr item) "}")) out)) (value (princ (cond ((cadddr item) (cat "{{value " (cat (caddr item) "}}"))) (t (cat "{value " (cat (caddr item) "}")))) out)) (t (pwarning (cat "unknown item in a pattern: " item)) ""))) ((literals branches) (prog nil (princ "{" out) (patterntostring (cadr item) out) (do (pattern (&pattern& (cddr item) (cdr &pattern&)) glisp::&v) ((atom &pattern&) glisp::&v) (setq pattern (car &pattern&)) (setq glisp::&v (progn (princ ", " out) (patterntostring pattern out)))) (princ "} " out) (return 0))) (rewritesto (princ "->" out)) (t (pwarning (cat "unknown item in a pattern: " item))))))) (defun identifier nil (let ((atm (peek))) (cond ((and (symbolp atm) (not (get atm (quote delimiter)))) (next)) (t (failure "an identifier"))))) (defun adelimiter nil (let ((atm (peek))) (cond ((and (symbolp atm) (get atm (quote delimiter))) (next)) (t (failure "a delimiter"))))) (defun anumber nil (cond ((numberp (peek)) (next)) (t (failure "a number")))) (defun astring nil (cond ((stringp (peek)) (next)) (t (failure "a string")))) (defun atype (typ) (cond ((typep (peek) typ) (next)) (t (failure (cat "an item of type '" (cat typ "'")))))) (defun reservedword nil (let ((atm (peek))) (cond ((and (symbolp atm) (get atm !sourcelanguage)) (next)) (t (failure "a reserved word"))))) (defun nonreservedword nil (let ((atm (peek))) (cond ((and (symbolp atm) (not (get atm (quote delimiter))) (not (get atm !sourcelanguage))) (next)) (t (failure "a non reserved-word identifier"))))) (defun eof nil (cond ((eq (peek) !eof) !novalue) (t (failure !eof)))) (defun isnot (x) (cond ((equalp (peek) x) (failure (cat "to not find '" (cat x "'")))) (t !novalue))) (defun flush nil (setf !savedsources nil) !novalue) (defun pvariable (&optional (var (identifier)) (onleft (leftside?))) (canonicalname var onleft)) (defun lhs nil (prog nil (setf !varnames nil) (push nil !sidestack) (return !novalue))) (defun rhs nil (prog nil (cond ((leftside?) (setf !varnames (reverse !varnames)))) (push t !sidestack) (return !novalue))) (defun phs nil (prog nil (pop !sidestack) (cond ((leftside?) (setf !varnames (reverse !varnames)))) (return !novalue))) (defun onleft nil (cond ((leftside?) !novalue) (t (failure)))) (defun onright nil (cond ((rightside?) !novalue) (t (failure)))) (defun pwarning (&rest messages) (prog nil (fresh-line *pstandard-output*) (princ "*** Warning, " *pstandard-output*) (do (m (&m& messages (cdr &m&)) glisp::&v) ((atom &m&) glisp::&v) (setq m (car &m&)) (setq glisp::&v (princ m *pstandard-output*))) (terpri *pstandard-output*) (return !novalue))) (defun perror (&rest messages) (prog ((*readtable* *lisp-readtable*)) (terpri *perror-output*) (printc "*** Error," *perror-output*) (do (m (&m& messages (cdr &m&)) glisp::&v) ((atom &m&) glisp::&v) (setq m (car &m&)) (setq glisp::&v (princ m *perror-output*))) (printc "*** Input:") (princlist (rest !source) *perror-output*) (terpri *perror-output*) (terpri *perror-output*) (break) (setf !source (xnew)) (failure))) (defun checkfunction (fn) (prog nil (cond ((and (symbolp fn) (fboundp fn)) (pwarning "function redefined: " fn) (setf !nredefined (+ !nredefined 1))) (t (princatom fn *pstandard-output*))) (return !novalue))) (defun empty? nil (or (xnull? !source) (eq (cadr !source) !eof))) (defun peek nil (cond ((empty?) !eof) (t (cadr !source)))) (defun next nil (cond ((null !sourcestream) (cond ((empty?) (failure)) ((eq !farthesttail (cdr !source)) (prog1 (xpop !source) (setf !farthesttail (cdr !source)))) (t (xpop !source)))) ((cddr !source) (xpop !source)) (t (prog (x) (setf !farthestfailure nil) (setf !farthestfunction nil) (setf !farthestindex (ask !sourcestream (currindex))) (setf x (read-preserving-whitespace !sourcestream nil !eof nil)) (setf !source (xcons !source x)) (cond ((eq x (quote \')) (setf !source (xcons !source (readsexpression !sourcestream))))) (return (xpop !source)))))) (defun nextis? (x) (cond ((equalp (peek) x) (next) t) (t nil))) (defun nextare? (l) (every (function (lambda (x) (nextis? x))) l)) (defun failure (&optional message override) (prog nil (cond ((and !ptrace (get !currentplispfunction (quote pfulltrace)) message) (prog nil (indentedprintc "item failed: " message) (indentedprintc "input: ") (princlist (rest !source) *ptrace-output*) (terpri *ptrace-output*) (cond ((get !currentplispfunction (quote ptrap)) (pbreak)))))) (recordmessage message override) (throw !failure t))) (defun failurevalue? (value) (and (consp value) (eq (first value) !failure))) (defun plispfunction? (fn) (and (symbolp fn) (get fn (quote pfunction)))) (defun leftside? nil (not (car !sidestack))) (defun rightside? nil (car !sidestack)) (defun cat (x y) (concatenate (quote string) (str x) (str y))) (defun neql (x y) (not (eql x y))) (defun nequal (x y) (not (equal x y))) (defun nequalp (x y) (not (equalp x y))) (defun plist (x) (symbol-plist x)) (defun pname (x) (symbol-name x)) (defun printc (x &optional (stream nil)) (terpri stream) (princ x stream) (princ " " stream) x) (defun str (x) (cond ((stringp x) x) ((symbolp x) (symbol-name x)) (t (princ-to-string x)))) (defun peval (l &key (source (quote glisp)) (target nil) (readtable *glisp-readtable*)) (cond ((consp l) (papply (first l) (rest l) :source source :target target :readtable readtable)) (t (error "the argument to 'peval' must be a list: ~a" l)))) (defun papply (pfn args &key ((:source !sourcelanguage) (quote glisp)) ((:target !targetlanguage) nil) ((:readtable *readtable*) *glisp-readtable*)) (prog (!source !sourcestream !farthesttail (!savedsources nil) (!sourcestack nil) (!deststack nil) (!sidestack nil) (!varnames nil) (!farthestfailure nil) (!farthestfunction pfn) (!farthestindex 0) (!currentplispfunction pfn) (!pindent 0) value) (cond ((not (plispfunction? pfn)) (return (error "the first argument to 'papply' must be the name of a Plisp function: ~a" pfn)))) (typecase args (list (setf !sourcestream nil) (setf !source (xhead args)) (setf !farthesttail (rest !source))) (stream (setf !sourcestream args) (setf !source (xhead (list (read-preserving-whitespace !sourcestream nil !eof nil)))) (setf !farthesttail nil)) (otherwise (return (error (cat "the second argument to 'papply' must be a list " " or a stream, not a ~a") (type-of args))))) (return (cond ((failed? (setf value (apply pfn nil))) (list !failure !source (cat "<" (cat (cond (!farthestfunction (string-downcase !farthestfunction)) (t "an unknown function")) (cat "> expected " (or !farthestfailure "something")))) (cond ((listp args) !farthesttail) (t !farthestindex)))) ((or (atom value) (rest value)) value) (t (first value)))))) (defun pcall (pfn args) (prog (value) (cond (args (setf !source (xprepend (copy-list args) !source)))) (setf value (apply pfn nil)) (return (cond ((consp value) (car value)) (t value))))) (defun parse (ifile &key ((:output ofile) nil) (pretty nil) (evaluate t) (asstring nil) (source (quote glisp)) (target nil) (parser (quote glispprogram)) (readtable *glisp-readtable*) (package nil)) (prog (tim value (!reservedwords nil) (!nredefined 0) (*package* (cond (package (or (find-package package) (return (error (cat "no such package: " package))))) (t *package*)))) (cond ((and (stringp ifile) (not asstring)) (announce ifile ofile))) (printc "----------" *pstandard-output*) (terpri *pstandard-output*) (setf tim (get-internal-run-time)) (setf value (cond ((null ifile) (parsestring (read-line t nil !eof nil) parser :source source :target target :readtable readtable)) ((and asstring (stringp ifile)) (parsestring ifile parser :source source :target target :readtable readtable)) ((stringp ifile) (parsefile ifile parser :source source :target target :readtable readtable)) ((listp ifile) (parselist ifile parser :source source :target target :readtable readtable)) ((streamp ifile) (parsestream ifile parser :source source :target target :readtable readtable)) (t (return (error (cat "the first argument to 'parse' must be a string, " "list, or stream, not a ~a: ~a") (type-of ifile) ifile))))) (setf tim (/ (- (get-internal-run-time) tim) internal-time-units-per-second)) (fresh-line *pstandard-output*) (princ "----------" *pstandard-output*) (cond ((eq value !failure) (return !failure))) (printc (cat (round (float tim)) " seconds translation time") *pstandard-output*) (printc (cat !nredefined " functions redefined") *pstandard-output*) (cond (ofile (printtranslation value ofile pretty)) (evaluate (prog nil (terpri *pstandard-output*) (printc "Evaluating the translation..." *pstandard-output*) (do (x (&x& value (cdr &x&)) glisp::&v) ((atom &x&) glisp::&v) (setq x (car &x&)) (setq glisp::&v (eval x)))))) (terpri *pstandard-output*) (terpri *pstandard-output*) (return (cond ((not evaluate) value) (package *package*) (t (quote done)))))) (defun parsefile (filename parser &key (source (quote glisp)) (target nil) (readtable *glisp-readtable*)) (prog (value) (with-open-file (stream (merge-pathnames filename) :direction :input :element-type (quote character) :if-does-not-exist :error) (setf value (papply parser stream :source source :target target :readtable readtable)) (cond ((failurevalue? value) (explainerror value stream) (setf value !failure)))) (return value))) (defun parsestring (s parser &key (source (quote glisp)) (target nil) (readtable *glisp-readtable*)) (prog (value) (with-input-from-string (stream s) (setf value (papply parser stream :source source :target target :readtable readtable)) (cond ((failurevalue? value) (explainerror value s (ask stream ccl::end)) (setf value !failure)))) (return value))) (defun parselist (l parser &key (source (quote glisp)) (target nil) (readtable *glisp-readtable*)) (prog (value) (setf value (papply parser l :source source :target target :readtable readtable)) (cond ((failurevalue? value) (explainerror value l) (setf value !failure))) (return value))) (defun parsestream (s parser &key (source (quote glisp)) (target nil) (readtable *glisp-readtable*)) (parselist s parser :source source :target target :readtable readtable)) (defun reparse (name filename &key (source (quote glisp)) (target nil) (parser (quote reparseplispfunction)) (locater (quote locateplispfunction)) (readtable *glisp-readtable*) (package nil)) (prog (value (!reservedwords nil) (!nredefined 0) (*package* (cond (package (or (find-package package) (return (error (cat "no such package: " package))))) (t *package*)))) (cond (package (setf name (intern (pname name))))) (with-open-file (stream (merge-pathnames filename) :direction :input :element-type (quote character) :if-does-not-exist :error) (cond ((apply locater (list name stream readtable)) (prog nil (setf value (papply parser stream :source source :target target :readtable readtable)) (cond ((failurevalue? value) (explainerror value stream)) (t (prog nil (cond (target (addreservedwords target !reservedwords))) (eval value)))))) (t (printc (cat "Item not found: " name) *pstandard-output*)))) (return *package*))) (defun locateplispfunction (name stream *readtable*) (prog ((x (quote \;)) index foundit) (do (glisp::&v) ((and (or (eq x (quote \;)) (eq x (quote -)) (eq x !eof)) (case x (\; (prog nil (setf index (file-position stream)) (setf foundit (and (eq (read stream nil !eof nil) name) (member (read stream nil !eof nil) (quote (= \())))) (file-position stream index) (return foundit))) (- (prog nil (setf index (file-position stream)) (setf foundit (and (eq (read stream nil !eof nil) (quote plisp)) (eq (read stream nil !eof nil) (quote -)) (setf index (file-position stream)) (eq (read stream nil !eof nil) name) (member (read stream nil !eof nil) (quote (= \())))) (file-position stream index) (return foundit))) (otherwise t))) (return glisp::&v)) (setq glisp::&v (setf x (read stream nil !eof nil)))) (return (neq x !eof)))) (defun printtranslation (l filename pretty) (prog ((*print-abbreviate-quote* nil)) (terpri *pstandard-output*) (setf filename (merge-pathnames filename)) (printc (cond (pretty "Pretty printing") (t "Printing")) *pstandard-output*) (princ (cat "the translation on " (cat (namestring filename) "...")) *pstandard-output*) (with-open-file (stream filename :direction :output :element-type (quote character) :if-exists :supersede :if-does-not-exist :create) (do (x (&x& l (cdr &x&)) glisp::&v) ((atom &x&) glisp::&v) (setq x (car &x&)) (setq glisp::&v (prog nil (cond (pretty (pprint x stream)) (t (print x stream))) (terpri stream))))))) (defun explainerror (value stream &optional (endpos nil)) (let ((!source (cadr value)) !sourcestream !sourcestack !currentplispfunction) (failed? (perror (caddr value) ": " (cond ((listp (cadddr value)) (cond ((cadddr value) (first (cadddr value))) (t "end of the input"))) (endpos (subseq stream (cadddr value) endpos)) ((consp stream) "") (t (file-position stream (cadddr value)) (read-line stream nil !eof nil))))))) (defun announce (ifile ofile) (prog nil (terpri *pstandard-output*) (princ (pathname-name ifile) *pstandard-output*) (cond ((pathname-type ifile) (princ (cat "." (pathname-type ifile)) *pstandard-output*))) (cond (ofile (princ (cat " -> " (pathname-name ofile)) *pstandard-output*) (cond ((pathname-type ofile) (princ (cat "." (pathname-type ofile)) *pstandard-output*))))) (princ "..." *pstandard-output*))) (defobfun (currindex *stream*) nil ccl::index) (defobfun (currindex ccl::*file-stream*) nil (file-position (self))) 
